COMMENT ⊗   VALID 00047 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	TITLE UTILTY  -  UTILITY ROUTINES  -  BRUCE G. BAUMGART  -  MAY 1974.
C00008 00003	INITIALIZE APR TRAP
C00010 00004	PRINT BACKTRACE
C00013 00005	WHAT USER CAN DO ABOUT ERROR
C00015 00006	WE GET HERE ON AT INTERRUPT
C00018 00007	TAKE CARE OF OVERFLOW.
C00022 00008	SUBROUTINES (WHICH USE PP INSTEAD OF P)
C00025 00009	DATA STORAGE
C00026 00010	ROUTINES TO PUSH AND POP ACCUMULATORS.
C00028 00011	TITLE ARITH  -  ARITHMETIC ROUTINES.
C00031 00012	SUBR(SIN)
C00033 00013	SUBR(ATAN,X)		ARC TANGENT
C00036 00014	SUBR(ATAN2,DY,DX)	ARC TANGENT (DELTA-Y,DELTA-X)
C00039 00015	SUBR(REALI)
C00041 00016	PRIMARY:
C00044 00017	TITLE III    - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.
C00045 00018	SUBR(DPYSET,BUFFER)		INITIALIZE A DISPLAY BUFFER.
C00047 00019	SUBRS AVECT,AIVECT,RVECT,RIVECT	Vectors
C00050 00020	SUBR(DPYSTR,TEXT)
C00053 00021	SUBRS OCTDPY,DECDPY,FLODPY	Numeric display
C00056 00022	TITLE MEMORY MANAGEMENT - BGB - FEBRUARY 1974.
C00057 00023	SAIL COMPATIBLITY ROUTINES.
C00059 00024	LISP COMPATIBLITY ROUTINES.
C00061 00025	SUBR(MKUNIV)		MAKE UNIVERSE.
C00064 00026	SUBR(MKCAMERA,WORLD)
C00066 00027	SUBR(MKWINDOW,CAMERA,WINDOW)	MAKE AND LINK A WINDOW NODE.
C00068 00028		FAIL MORE CORE.
C00070 00029		SAIL MORE CORE.
C00073 00030	SUBR(MKNODE,NODTYP)		ALLOCATE A BLOCK OF NODSIZ WORDS.
C00075 00031	TITLE IO - INPUT/OUTPUT - BGB - FEBRUARY 1973.
C00078 00032	SUBR(PLOTO)SAISTR	DISPLAY BUFFER TO DISK FILE.
C00079 00033	SUBR(TVHELP,FILLOC)	HELP - DISPLAY DOCUMENTATION.
C00082 00034	SUBN(GETFIL,EXT)	SETUP FILE SPEC FROM TTY LINE.
C00085 00035	SUBR(GETCHW)		GET CHARACTER WAIT.
C00087 00036	SUBN(SERIAL,BODY)	SERIAL NUMBER THE FEV OF A BODY FOR OUTPUT.
C00089 00037	SUBN(OFEV,BODY)		OUTPUT THE FEV OF A BODY.
C00091 00038	SUBN(OBODY,BODY)	OUTPUT BODY AND ITS PARTS.
C00092 00039	SUBR(OUTB3D,BODY)	OUTPUT B3D BODY.
C00094 00040	SUBR(INCAM)		INPUT CAMERA.
C00096 00041	SUBR(OUTCAM)		OUTPUT CAMERA.
C00098 00042	SUBN(IFEV,BODY)		INPUT F.E.V. BLOCKS.
C00101 00043	SUBN(IBODY,BODY0)	INPUT A BODY AND ALL ITS PARTS.
C00103 00044	SUBR(INB3D)		INPUT B3D FORMAT.
C00105 00045	SUBR(INGEO)		INPUT GEO COMMANDS.
C00107 00046	SUBR(OUTV2D)		OUTPUT VECTOR 2-D FILE FOR MAKE VIDEO.
C00109 00047	
C00112 ENDMK
C⊗;
TITLE UTILTY  -  UTILITY ROUTINES  -  BRUCE G. BAUMGART  -  MAY 1974.

.INSERT MN

	EXTERN JOBCNI,JOBAPR,JOBDDT,JOBHRL,JOBSA,JOBTPC,JOBREN,JOBOPC,PDL
	INTERN DDTGO
	IFNDEF PUSHIT<
	DEFINE PUSHACS<PUSHJ P,PUSHIT↑
	GLOBAL .PLEVEL↔.PLEVEL←←.PLEVEL+20>
	DEFINE POPACS<PUSHJ P,POPIT↑
	GLOBAL .PLEVEL↔.PLEVEL←←.PLEVEL-20>>

IFNDEF JENFIX<JENFIX←←0 >	;SET TO -1 WHEN INTJEN IS FIXED

	OPDEF INTJEN[723B8]
	OPDEF JRSTF[JRST 2,]

	CNT←14
	RA←15
	PP←16
	P←17
	INTTTI←←1B15		; INTERRUPT ON <ESC>I
	POV←←1B19		; INTERRHUPT ON PDL OV
	ILM←←1B22		; INTERRUPT ON ILL. MEM. REF.
	NXM←←1B23		; INTERRUPT ON NON-EX. MEM.
	INTFOV←←1B29		; INTERRUPT ON FOATING OVERFLOW
	INTOV←←1B32		; INTERRUPT ON ARITHMETIC ROVERFHLOW

	OVBOTH←←INTOV+INTFOV
	DEFINE INTFOR <FOR @` I ⊂ (INTTTI,POV,ILM,OVBOTH)>
;INITIALIZE APR TRAP
TRAPINIT↑:
;--------------------------------------------------------------------
	MOVEI 0,INTLOC↔DAC 0,JOBAPR
	IFN JENFIX <POP P,INTPC↔INTJEN INTWRD>
	IFE JENFIX <LAC 0,INTWRD↔INTENB 0,↔POPJ P,>

	XWD 777000,[SIXBIT/WARN./]
WARN.↑:	SETZM NOCONT↔GO FATAL2
	XWD 777000,[SIXBIT/FATAL./]
FATAL.↑:SETOM NOCONT↔SETZM ALWAYS
FATAL2:	SETOM ILOCK		;INTERLOCK AGAINST INTERRUPT
	POP P,INTPC
	DAC 0,ACSAVE		;SAVE STATE OF WORLD
	LAC 0,[XWD 1,ACSAVE+1]
	BLT ACSAVE+17

;TYPE THE MESSAGE STRING.
	SKIPE NOCONT↔OUTSTR[ASCIZ/FATAL:  /]
	SKIPN NOCONT↔OUTSTR[ASCIZ/WARNING:  /]
	LAC 0,@1(P)↔OUTSTR @0↔DAC 0,ERRTXT
	CRLF

	SETZ↔INTENB		;TURN OFF OUR ENABLINGS
	SETZM ILOCK		;RESET INTERLOCK, WE'RE SAFE NOW
	LAC PP,[IOWD 10,BKPDL]	;GET A TEMPORARY PDL
	SKIPE NOCONT↔GO BTRACE
	GO CONT
;PRINT BACKTRACE

	USERMODE←←1B5		;ALWAYS ON IN A PC
	PC.OFF←←1B4+1B6+37B17	;ALWAYS OFF IN A PC
				;1B4 is byte interrupt, never in user PDL
				;1B6 is IOT mode, almost never on in PDL

BTRACE:	CDR P,P		;GET READY TO PRINT A BACKTRACE
	OUTSTR[ASCIZ/
BACKTRACE: /]
PCLOOP:	LAC RA,(P)		;PICK UP WORD OFF OF STACK AND SEE IF IT'S A PC
	TLNE RA,(USERMODE)	;IS USER MODE ON?
	TLNE RA,(PC.OFF)	;AND OTHER DETERMINING BITS OFF?
	GO NOTPC		;NO, NOT A PC
	PUSH PP,RA		;LEFT HALF GOOD, NOW, IS IT IN OUR CORE IMAGE
	PUSHJ PP,ADRCHK
	GO NOTPC		;NO, PROBABLY NOT A PC
	MOVEI CNT,3		;DON'T LOOK MORE THAN THREE BACK
	OUTSTR[ASCIZ/ /]
PJLOOP:	SUBI RA,1↔JUMPLE RA,UNKNPJ
	CAR 0,(RA)↔CAIN 0,(<PUSHJ P,>)↔GO GOTPJ
	SOJG CNT,PJLOOP
UNKNPJ:	OUTSTR[ASCIZ/(?)/]	;WE DIDN'T FIND A PUSHJ, INDICATE AN UNKNOWN ROUTINE
	GO NOTPC		;AND LOOK FOR MORE

GOTPJ:	PUSH PP,(RA)		;WE FOUND A PUSHJ P,
	PUSHJ PP,ADRCHK		;CHECK ADDRESS
	GO UNKNPJ		;OOPS, PRINT BARF MESSAGE
	LDB 0,[POINT 12,-1(1),11]	;LOOK BACK AT SUBROUTINE-1
	CAIE 0,7770			;IS SPECIAL MARK THERE?
	GO [ LDB 0,[POINT 12,-1(1),11]	;NO, TRY BACK ANOTHER, IN CASE IT STARTS
	     CAIN 0,7770		;AT SUBROUTINE+1
	     GO [ LAC 1,-2(1)		;SPECIAL MARK THERE
		  PUSH PP,(1)		;PRINT NAME+1
		  PUSHJ PP,SIXOUT
		  OUTSTR[ASCIZ/+1/]
		  GO NOTPC ]
	     PUSH PP,1		;PRINT OCTAL OF SUBROUTINE ADDRESS
	     PUSHJ PP,OCTOUT
	     GO NOTPC ]
	LAC 1,-1(1)		;PRINT NAME OF ROUTINE
	PUSH PP,(1)
	PUSHJ PP,SIXOUT
NOTPC:	SOS P			;NOW, LETS TRY NEXT ONE DOWN
	CAIL P,PDL		;END YET?
	GO PCLOOP		;NO
	OUTSTR[ASCIZ/
/]				;YES, CRLF
	MOVSI 17,ACSAVE		;RESTORE ACS
	BLT 17,16
	SKIPN OVRGAG↔GO CMLOOP	;WE COULD FALL THRU BUT THIS IS SAFER
	GO CMLOOP
;WHAT USER CAN DO ABOUT ERROR
;
CMLOOP:	SKIPN NOCONT
	GO [ SKIPE ALWAYS↔GO CONT
	     OUTSTR [ASCIZ/→/]
	     GO CMLOO2]
	OUTSTR [ASCIZ/?/]
CMLOO2:	CLRBFI			;NO TYPE AHEAD, THANK YOU
	INCHRW 17↔ANDI 17,137	;WHAT DOES USER WANT TO DO
	CAIN 17,"R"↔GO @JOBREN
	CAIN 17,"S"↔GO [ CDR 17,JOBSA↔GO (17) ]
	CAIN 17,"D"↔GO DDTCALL
	CAIN 17,"α"↔GO CONT
	SKIPE NOCONT↔GO NOTCOM
	CAIN 17,12
	CAIE 17,15
	GO [	CAIN 17,12↔SETOM ALWAYS
	CONT:	SETZM ILOCK↔GO INTRT2 ]

NOTCOM:	OUTSTR[ASCIZ/???
D - DDT, R - REENTER, S - START/]
	SKIP NOCONT
	OUTSTR[ASCIZ/, <RETURN> CONTINUE
/]↔	OUTSTR[ASCIZ/
/]↔	OUTSTR @ERRTXT
	GO CMLOOP

;SEE IT DDT IS LOADED AND RUN IT
DDTCALL:SKIPN 17,JOBDDT
	GO [ OUTSTR[ASCIZ/
NO DDT.
?/]↔	       GO CMLOOP ]
IFE JENFIX
<	SETOM ILOCK		;WATCH THE RACE CONDITION
	LAC 17,INTPC
	DAC 17,JOBOPC
	OUTSTR[ASCIZ/
YOU'RE IN DDT.
/]
	LAC 17,INTWRD
	INTENB 17,
	LAC 17,ACSAVE+17
	SETZM ILOCK		;WATCH THE RACE CONDITION
	GO @JOBDDT
>
	OUTSTR [ASCIZ/
YOU'RE IN DDT.
/]
IFN JENFIX
<	LAC 17,ACSAVE+17
	INTJEN INTWRD
>
;WE GET HERE ON AT INTERRUPT
;
INTLOC:	SETZ		;TURN OFF INTERRUPTS, JUST IN CASE!
	INTENB
	DAC 5,STAT6	;REMEMBER THE STATUS OF PDP-6
	LAC 0,JOBCNI		;HOW DID WE GET HERE?
	INTFOR
<IFE I∧777777 < TLNE 0,(I)
>IFN I∧777777 < TRNE 0,I
>	GO [ MOVEI .`I
	     JRST USRRET ]
>
	MOVEI .UNKNOWN
USRRET:	DAC PCGO
	SKIPE ILOCK
	GO ILOSE
	UWAIT		;WHEN WE RETURN, WE'LL GET OUR AC'S BACK
	DAC 0,ACSAVE
	LAC 0,JOBTPC↔TLNN 0,USERMODE↔SETOM BAZFLG#↔DAC 0,INTPC
	LAC 0,[XWD 1,ACSAVE+1]
	BLT 0,ACSAVE+17
	DEBREAK
	LAC PP,[IOWD 10,BKPDL]
	JRSTF @PCGO

.POV:	OUTSTR[ASCIZ/?
PDL OV/]
	SOS INTPC		;INSTRUCTION WHERE IT REALLY HAPPENED
	PUSHJ PP,ATUSER
	GO IFATAL

.ILM:	PUSH PP,INTPC
	PUSHJ PP,ADRCHK
	GO [ OUTSTR[ASCIZ/?
PC OUT OF BOUNDS/]
	     GO .ILM2 ]
	OUTSTR[ASCIZ/?
ILL MEM REF/]
.ILM2:	PUSHJ PP,ATUSER
	GO IFATAL

.INTTT:	OUTSTR[ASCIZ/
<ESC> I  INTERRUPT/]
	PUSHJ PP,ATUSER
	SETZM NOCONT
	SETZM ALWAYS
	GO BTRACE

.UNKNO:	OUTSTR[ASCIZ/?
UNEXPECTED INTERRUPT/]
	PUSHJ PP,ATUSER
	GO IFATAL

IFATAL:	SETOM NOCONT
	SETZM ALWAYS
	GO BTRACE

ILOSE:	CAIN .INTTTI
	GO [ LAC 0,INTWRD	;WE'RE ALREADY IN AN ERROR ROUTINE
	       INTENB 0,
	       DISMIS ]
	LAC 0,JOBTPC
	DAC 0,INTPC
	UWAIT		;GET BACK USER ACS, ETC.
	DEBREAK		;GET BACK TO USER LEVEL
	OUTSTR[ASCIZ/?
INTERRUPT OCCURED DURING ERROR ROUTINE!  /]
	HALT .+1
	JRSTF @INTPC
;TAKE CARE OF OVERFLOW.
.OVBOTH:LAC 0,INTPC
	TLNE 0,000040		;TEST ZERO DIVIDE
	GO [ SKIPN OVRGAG	;DIVISION BY ZERO RESULTS IN INFINITY!
	     OUTSTR[ASCIZ/DIVISION BY ZERO/]
	     LAC 0,[377777777777]
	     GO FIXOVER ]
	TLNE 0,000100		;TEST FLOATING UNDERFLOW
 	GO [ SKIPN OVRGAG	;SET TO ZERO
	     OUTSTR[ASCIZ/FLOATING UNDERFLOW/]
	     SETZ 0,
	     GO FIXOVER ]
	TLNE 0,040000
	GO [	SKIPN OVRGAG
		OUTSTR[ASCIZ/FLOATING OVERFLOW/]
		LAC 0,[377777777777]	;FLOATING OVERFLOW PRODUCES INFINITY
		GO FIXOVER ]
	TLNN 0,400000		;INTEGER OVERFLOW?
	HALT .+1
	MOVSI 1,400000
	ANDCAM 1,INTPC
	GO INTRET
FIXOVER:DAC 0,OVFIX
	SKIPN OVRGAG
	PUSHJ PP,ATUSER
	MOVSI 1,440140		;TURN OFF LOSING BITS
	ANDCAB 1,INTPC
	LAC 1,-1(1)		;IT HAPPENED AT PC-1

XCLOOP:	LDB 2,[POINT 9,1,8]		;GET OPCODE
	CAIN 2,<XCT>/1B8		;IS IT AN XCT INSTRUCTION
	GO [ TLZ 1,777400		;TURN OFF OPCODE
	       TLO 1,(<LAC 1,>)
	       DAC 1,OVINST
	       MOVSI 17,ACSAVE		;YES, TRY NEXT ONE IN CHAIN
	       BLT 17,16
	       LAC 17,ACSAVE+17
	       XCT OVINST
	       GO XCLOOP ]
	DAC 1,OVINST
	TLZ 1,777740		;TURN IT INTO A MOVEI TO CALCULATE EFFECTIVE ADDRESS
	TLO 1,(<MOVEI 2,>)
	DAC 1,OVOP
	MOVSI 17,ACSAVE		;GET ACS FOR EFFECTIVE ADDRESS CALCULATION
	BLT 17,16
	LAC 17,ACSAVE+17
	XCT OVOP		;DO ADDRESS CALCULATION, PUTTING RESULT INTO AC.2
	CAIGE 2,17		;IN CASE THE EFFECTIVE ADDRESS IN AN AC
	ADDI 2,ACSAVE		;POINT TO SAVED ACS
	LDB 3,[POINT 4,OVINST,12];GET AC FIELD INTO AC.3
	ADDI 3,ACSAVE		;POINT TO SAVED ACS
	LDB 1,[POINT 9,OVINST,8];GET OPCODE
	LAC 0,OVFIX	
	CAIN 1,<FSC>/1B8	;SPECIAL TEST FOR FSC
	GO [ SETZ 1,		;RESULT INTO AC.0
	       GO NTEST2 ]
	CAILE 1,140↔CAILE 1,177↔GO NTEST	;FLOATING IMMEDIATE.
	ANDI 1,7↔CAIE 1,5↔	GO NTEST
	MOVSS 2,2↔SKIPGE 2↔MOVN 0,0
	GO NTEST2

NTEST:	ANDI 1,3↔CAIN 1,1↔GO NTEST2
	SKIPGE (2)↔MOVN 0,0		;CHANGE SIGN AS IF (MEMORY)<0
NTEST2:	SKIPGE (3)↔MOVN 0,0		;CHANGE SIGN IF (AC)<0
	SKIPN (3)↔SETZ			;MAKE 0/0=0
	ANDI 1,3↔TRNE 1,2↔DAC 0,(2)	;RESULT TO MEMORY.
	CAIE 1,2↔DAC 0,(3)		;RESULT TO ACCUMULATOR.
INTRET:	MOVSI 17,ACSAVE
	BLT 17,16
INTRT2:
	LAC 17,INTWRD
	INTENB 17,
	LAC 17,ACSAVE+17
	JRSTF @INTPC
;SUBROUTINES (WHICH USE PP INSTEAD OF P)
;--------------------------------------------------------------------
; Routine to check to make sure RH is in core image.  Returns RH is 1
; and skips if legal address
ADRCHK:	CDR 1,-1(PP)
	CAMLE 1,JOBREL
	GO [ CAIL 1,400000	;(DON'T NEGLECT UPPER!)
	     CAILE 1,JOBHRL
	     GO POPP1J
	     GO .+1]
	AOS (PP)
POPP1J:	SUB PP,[XWD 2,2]↔GO @2(PP)
;--------------------------------------------------------------------
; Print a right half in octal	(if called at OCTOUT+1, print left half)
OCTOUT:	MOVSS -1(PP)			;LAC INTO LEFT HALF
	SKIPA 4,[[ ROTC 3↔"0" ]]	;WE CAN SHARE CODE WITH SIXOUT
; Print a number in sixbit
SIXOUT:	MOVEI 4,[ ROTC 6↔" "]	;(TO SHARE WITH OCTOUT)
	MOVEI 3,6		;NUMBER OF CHARACTERS
	LAC 1,-1(PP)		;GET ARG.
SXLOOP:	SETZ 0,			;CLEAR AC WERE ABOUT TO ROTC INTO
	XCT (4)			;GET HIGH ORDER DIGIT/CHARACTER
	ADD 0,1(4)		;ADD APPROPRIATE THING
	OUTCHR 0		;OUTPUT
	CAIE 0," "		;TEST FOR END.
	SOJG 3,SXLOOP		;MORE TO COME
	SUB PP,[XWD 2,2]	;WE'RE DONE, RETURN
	JRSTF @2(PP)
;--------------------------------------------------------------------
;PRINT ' AT USER 000000'
ATUSER:	PUSH PP,0		;SAVE AC 0
	OUTSTR [ASCIZ/ AT USER /]
	PUSH PP,INTPC
	PUSHJ PP,OCTOUT
	OUTSTR [ASCIZ/
/]↔	POP PP,0↔POPJ PP,
;--------------------------------------------------------------------
;DATA STORAGE
ACSAVE:	BLOCK 20
BKPDL:	BLOCK 10

;INTWRD AND INTPC MUST BE IN ORDER OR INTJEN WILL LOSE!
	.INTWRD←←0
	INTFOR <.INTWRD←←.INTWRD!I
>
INTWRD:	.INTWRD
INTPC:	BLOCK 1

PCGO:	BLOCK 1

ILOCK:	BLOCK 1
STAT6:	BLOCK 1

OVFIX:	BLOCK 1
OVOP:	BLOCK 1
OVINST:	BLOCK 1

NOCONT:	BLOCK 1
ALWAYS:	BLOCK 1
OVRGAG:		-1	;SHUT UP !!
ERRTXT:	BLOCK 1
;ROUTINES TO PUSH AND POP ACCUMULATORS.

IFNDEF PUSHIT <
↑↑PUSHIT:
	PUSH P,0	; SAVE 0
	HLRE 0,P	; PICK UP COUNT
	ADDI 0,20	; ADD IN DISPLACEMENT
	XOR 0,P		; IF SIGNS ARE DIFFERENT, NOT ENOUGH STACK
	JUMPGE 0,PUSHOK
	POP P,0		; CAN'T DO IT, LOSE BIG
	OUTSTR [ASCIZ ⊗NOT ENOUGH ROOM TO PUSH ACS!!
⊗]
	SKIPN JOBDDT
	GO [ OUTSTR[ASCIZ⊗YOU LOSE.	⊗]
	       HALT PUSHIT ]
↑↑DDTGO:OUTSTR[ASCIZ⊗YOU'RE IN DDT
⊗]
	POP P,JOBOPC
	GO @JOBDDT
PUSHOK:	POP P,0		; GET BACK 0
	EXCH 0,(P)	;SAVE 0 AND GET RETURN.
	DAC 0,20(P)	;GEE, THIS WAY WE RETURN WITH A POPJ
	MOVEI 0,1(P)
	HRLI 0,1
	BLT 0,17(P)
	ADD P,[XWD 20,20]
	POPJ P,		;RETURN TO SENDER

↑↑POPIT:
	MOVSI 0,-17(P)
	HRRI 0,1
	BLT 0,17
	LAC 0,20(P)
	EXCH 0,(P)
	POPJ P,
>
;TITLE ARITH  -  ARITHMETIC ROUTINES.

	HALFPI↑:	201622077325 ;PI/2
	PI↑:		202622077325 ;PI
	TWOPI↑:		203622077325 ;2*PI

SUBR(SQRT,X)		;SQUARE ROOT OF ABS(X).
COMMENT .-----------------------------------------------------------.
	A←←0 ↔ B←←1 ↔ C←←2
	MOVM B,X↔JUMPE B,POP1J.↔PUSHP 2

;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
	ASHC B,-=27↔SUBI B,201	;GET EXPONENT IN B, FRACTION IN C.
	ROT B,-1		;CUT EXP IN HALF, SAVE ODD BIT
	DAP B,L↔LSH B,-=35	;USE THAT ODD BIT.
	ASH C,-10↔FSC C,177(B)	;0.25 < FRACTION < 1.00

;LINEAR APPROXIMATION TO SQRT(F).
	DAC C,A
	FMP C,[0.8125↔0.578125](B)
	FAD C,[0.302734↔0.421875](B)

;TWO ITERATIONS OF NEWTON'S METHOD.
	LAC B,A
	FDV B,C↔FAD C,B↔FSC C,-1
	FDV A,C↔FADR A,C
     L: FSC A,0↔LAC 1,A↔POPP 2
	POP1J
ENDR SQRT; BGB 28 DECEMBER 1972 -------------------------------------

SUBR(LOG,X)	;NATURAL LOGRITHM.
COMMENT .-----------------------------------------------------------.
	MOVM X↔SKIPE 1,0↔CAMN 0,[1.0]↔POP1J
	ASHC 0,-33↔ADDI 0,211000↔MOVSM 0,TMP1#
	MOVSI 0,(-128.5)↔FADM 0,TMP1
	ASH 1,-10↔TLC 1,200000↔FAD 1,[-0.70710678]
	LAC 0,1↔FAD 0,[1.4142135]↔FDV 1,0
	DAC 1,TMP2#↔FMP 1,1
	LAC 0,[0.59897864]↔FMP 0,1
	FAD 0,[0.96147063]↔FMP 0,1
	FAD 0,[2.88539120]↔FMP 0,TMP2↔FAD 0,TMP1
	FMP 0,[0.69314718]↔LAC 1,0↔POP1J
	VAR
ENDR LOG;---------------------------------------------------------
SUBR(SIN)
	GO SIN.↔ENDR SIN
SUBR(COS)
	GO COS.↔ENDR COS
	
BEGIN SINCOS			;MODIFIED OLDE LIB40 SINE & COSINE - BGB.
	A←←1 ↔ B←←2 ↔ C←←3
↑COS.:	SKIPA A,-1(P)
↑SIN.:	SKIPA A,-1(P)
	FADR  A,HALFPI			;COS(X) = SIN(X+π/2).
	MOVM B,A↔CAMG B,[17B5]↔POP1J	;FOR SMALL X, SIN(X)=X.

;B ← (ABS(X)MODULO 2π)/HALFPI
;C ← QUADRANT 0, 1, 2 OR 3.
	FDVR B,HALFPI
	LAC C,B↔KAFIX C,233000
	CAILE C,3↔GO[
	TRZ C,3↔FSC C,233
	FSBR B,C↔GO .-3]		;MODULO 2π.
	GO .+1(C)↔GO .+4↔JFCL↔GO[
	FSBRI B,(2.0)↔MOVNS B↔GO .+2]	;SIN(X+π)=SIN(-X)
	FSBRI B,(4.0)			;SIN(X+2π)=SIN(X)
	SKIPGE A↔MOVNS	B		;SIN(-X) = -SIN(X).

;FOR -1 ≤ B ≤ +1 REPRESENTING -π/2 ≤ X ≤ +π/2,
;COMPUTE SINE(X) APPROXIMATION BY TAYLOR SERIES.
	DAC B,C↔FMPR B,B	
	LAC A,[164475536722]↔FMP A,B
	FAD A,[606315546346]↔FMP A,B
	FAD A,[175506321276]↔FMP A,B
	FAD A,[577265210372]↔FMP A,B
	FAD A,HALFPI↔FMPR A,C↔POP1J
	LIT
BEND SINCOS;---------------------------------------------------------
SUBR(ATAN,X)		;ARC TANGENT
COMMENT ⊗------------------------------------------------------------
	IF 0.0 < X ≤ 1.0 THEN ⊂ Z ← X*X;
	RETURN (ATAN(X) = X*(B0+A1/(Z+B1-A2/(Z+B2-A3/(Z+B3)))));⊃;
	IF X>1 THEN ATAN(X) = PI/2 - ATAN(1/X);
	IF X>1 THEN RH(D) =-1, AND LH(D) = -SGN(X)
	IF X<1, THEN RH(D) = 0, AND LH(D) =  SGN(X)
⊗
	A←←1 ↔ B←←2 ↔ C←←3 ↔ D←←4 ↔ E←←5
	LAC	A,X		;PICK UP THE ARGUMENT IN A
ATAN1:	MOVM	B, A		;GET ABSF OF ARGUMENT
	CAMG	B, A1		;IF X<2↑-33, THEN RETURN WITH...
	POP1J		;ATAN(X) = X
	HLLO	D, A		;SAVE SIGN, SET RH(D) = -1
	CAML	B, A2		;IF A>2↑33, THEN RETURN WITH
	GO[LAC A,HALFPI ↔POP1J];	ATAN(X) = PI/2
	MOVSI	C,(<1.0>)	;FORM 1.0 IN C
	CAMG	B, C		;IS ABSF(X)>1.0?
	TRZA	D, -1		;IF B ≤ 1.0, THEN RH(D) = 0
	FDVM	C, B		;B IS REPLACED BY 1.0/B
	TLC	D, (D)		;XOR SIGN WITH > 1.0 INDICATOR

	DAC B,E↔FMP B,B
	LAC C,B↔FAD C,KB3↔LAC A,KA3↔FDVM A,C
	FAD C,B↔FAD C,KB2↔LAC A,KA2↔FDVM A,C
	FAD C,B↔FAD C,KB1↔LAC A,KA1↔FDV  A,C
	FAD A,KB0↔FMP A,E

	TRNE	D, -1		;CHECK > 1.0 INDICATOR
	FSB	A, HALFPI		;ATAN(A) = -(ATAN(1/A)-PI/2)
	SKIPGE	D		;LH(D) = -SGN(B) IF B>1.0
	MOVNS A		;NEGATE ANSWER
	POP1J		;EXIT
A1:	145000000000		;2↑-33
A2:	233000000000		;2↑33

KB0:	176545543401		;0.1746554388
KB1:	203660615617		;6.762139240
KB2:	202650373270		;3.316335425
KB3:	201562663021		;1.448631538

KA1:	202732621643		;3.709256262
KA2:	574071125540		;-7.106760045
KA3:	600360700773		;-0.2647686202
ENDR ATAN;--------------------------------------------------------
SUBR(ATAN2,DY,DX)	;ARC TANGENT (DELTA-Y,DELTA-X)
COMMENT .-----------------------------------------------------------.
; OMEGA ← ATAN2(Y,X).
	Y←←1 ↔ X←←2
	MOVM Y,DY↔MOVM X,DX
	CAMN X,Y↔JUMPE Y,L2
	CAML Y,X↔GO L1

;HORIZONTAL TO π/2; ABS(Y) < ABS(X).
	LAC  Y,DY↔FDVR Y,DX
	PUSH 17,Y↔PUSHJ 17,ATAN		;ARCTAN(Y/X)
	SKIPL DX↔POP2J			;1ST & 2ND QUADRANTS.
	JUMPGE Y,[
	FSBR Y,PI↔POP2J]		;3RD QUADRANT.
	FADR Y,PI↔POP2J			;2ND QUADRANT.

;VERTICAL TO π/2; ABS(X) < ABS(Y).
L1:	MOVN X,DX↔FDVR X,DY
	PUSH 17,X↔PUSHJ 17,ATAN		;ARCTAN(X/Y)
	SKIPG DY↔GO[
	FSB Y,HALFPI↔POP2J]
	FADR Y,HALFPI
L2:	POP2J

ENDR ATAN2;----------------------------------------------------------

SUBR(ASIN,X)	;ARC SINE.
COMMENT .-----------------------------------------------------------.
; ASIN(X)=ATAN(X/SQRT(1-X↑2)).
; GIVEN -1 ≤ X ≤ +1 RETURN -π/2 ≤ ASIN(X) ≤ +π/2.
	A←1 ↔ B←2
	MOVN A,X↔FMPR A,X↔FADRI A,(1.0)
	JUMPE A,[LAC A,HALFPI		;WAS X EITHER -1.0 OR 1.0?
	SKIPGE X↔MOVNS A↔POP1J]
	CALL(SQRT,A)
	LAC B,X↔FDVR B,1↔DAC B,X	;CALCULATE X/SQRT(1-X↑2)
	EX.			;To fix over-AOSing ENTERS
	GO ATAN			;CALCULATE ATAN(SQRT(1-X↑2))
ENDR ASIN;-----------------------------------------------------------

SUBR(ACOS,X)	;ARC COSINE.
COMMENT .-----------------------------------------------------------.
; ACOS(X)= π/2 - ASIN(X).
; GIVEN -1 ≤ X ≤ +1 RETURN 0 ≤ ACOS(X) ≤ +π.
	CALL(ASIN,X)
	MOVNS 1↔FADR 1,HALFPI
	POP1J
ENDR ACOS;--------------------------------------------------------
SUBR(REALI)
COMMENT ⊗------------------------------------------------------------
 <EXPR>		::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
 <TERM>		::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
 <PRIMARY>	::= -<PRIMARY>|(<EXPR>)|π|<REAL NUMBER> ⊗

REAL0:	CALL(TERM)
REAL1:	CAIN 1,"+"↔GO[PUSH P,0
	     CALL(TERM)↔FADR 0,(P)
  	     SUB P,[XWD 1,1]↔GO REAL1]
	CAIN 1,"-"↔GO[PUSH P,0
	     CALL(TERM)↔MOVN 0,0
	     FADR 0,(P)
  	     SUB P,[XWD 1,1]↔GO REAL1]
	CAIN 1,15↔CALL(GETCHL)		;CARRIAGE RETURN - LINE FEED.
	POP0J
;--------------------------------------------------------------------
TERM:	CALL(PRIMARY)
TERM2:	CAIN 1,"*"↔GO[PUSH P,0
	     CALL(PRIMARY)↔FMPR 0,(P)
  	     SUB P,[XWD 1,1]↔GO TERM2 ]
	CAIN 1,"/"↔GO[PUSH P,0
	     CALL(PRIMARY)↔EXCH 0,(P)
	     FDVR 0,(P)
  	     SUB P,[XWD 1,1]↔GO TERM2 ]
	POPJ P,
;--------------------------------------------------------------------
PRIMARY:
BEGIN PRIMARY;-------------------------------------------------------
ITG ←← 0	;INTEGER ACCUMULATION.	 AC-0 RETURNS REAL NUMBER
CHR ←← 1	;CHARACTER JUST SCANNED. AC-1 RETURNS BREAK CHR.
CNT ←← 2	;COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT +1.
FLG ←← 3	;MINUS SIGN FLAG.

	SETZ ITG↔SETZB CNT,FLG				;INITIALIZATION.
L0:	CALL(GETCHL)					;FIRST CHARACTER.
	CAIN 1," "↔GO L0				;LEADING BLANKS.
	CAIN 1,"-"↔GO[SETCMM 3↔GO L0]			;UNARY MINUS SIGNS.
	CAIN 1,"π"↔GO[LAC 0,PI↔GO L3]			;PI
	CAIN 1,"("↔GO[PUSH P,FLG↔CALL(REALI)↔POP P,FLG	;PARENTHESES
		CAIN 1,")"↔GO L3
		OUTSTR[ASCIZ/WARNING: MISSING ')'/]↔CRLF
		POPJ P,]
	SKIPA
L1:	CALL(GETCHL)
	CAIE CHR,"."↔GO .+3
	JUMPN CNT,L2		;EXIT IF THIS IS A 2ND DECIMAL POINT.
	AOJA  CNT,L1		;BEGIN COUNT OF DIGITS TO RIGHT OF DECIMAL POINT.

	CAIL CHR,"0"↔CAILE CHR,"9"↔GO L2	;DIGITS FALL THRU.
	TLNE 777000↔GO L1			;27-BIT MANTISSA IS ENOUGH.
	SKIPE CNT↔AOS CNT			;COUNT DIGITS RIGHT OF DECIMAL.
	ANDI 1,17↔IMULI =10↔ADD 1↔GO L1		;ACCUMULATE A DIGIT.

L2:	TLNE 777000↔GO[LSH -3↔FLOAT↔FSC 3↔GO .+2]
	FLOAT↔CAIL CNT,2
	FDVR[1E1↔1E2↔1E3↔1E4↔1E5↔1E6↔1E7↔1E8↔1E9↔1E10]-2(2) ;SCALE MANTISSA.
	CAIN CHR,42↔GO[FDVR[12.0]↔GO L3]		;INCHES ?
	CAIN CHR,"`"↔GO[FMPR[1.74532925E-2]↔GO L3]	;DEGREES ?
	CAIN CHR,"'"↔GO[FMPR[2.90888208E-4]↔GO L3]	;MINUTES OF ARC ?
	SKIPA
L3:	CALL(GETCHL)
	SKIPE 3↔MOVNS		;SIGNED.
	POPJ P,
BEND PRIMARY
ENDR REALI;12/16/72(BGB),14-MAR-73(TVR)------------------------------
;TITLE III    - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.


BUFDPY↑: .+2↔=250
	BLOCK =260

DPYBUF↑:DPYBU.↔=6000 
DPYBU.: BLOCK =6000

IGNORE:		0
SIZBRT:		0
DPYCOL:		0
DPYPTR↑:	0
BUFEND:		0
BUFHD:		0↔0		;UPG ARGUMENT. ;ADDRESS ↔ LENGTH.

;VERNIER III TEXT POSITIONING.
	VERNX ←← 14
	VERNY ←← 11

;DISPLAY SAIL STRING.
DPYSST↑: POP 16,1↔POP 16,2↔SKIPGE IGNORE↔POPJ P,
	HRRZS 2			;LENGTH	OF STRING.
	JUMPLE 2,SSRET
	ILDB 3,1
	IDPB 3,DPYPTR
	SOJG 2,.-2
SSRET:	HRRZ 1,DPYPTR
	CAML 1,BUFEND
	SETOM IGNORE
	POPJ P,
SUBR(DPYSET,BUFFER)		;INITIALIZE A DISPLAY BUFFER.
COMMENT .-----------------------------------------------------------.
	A←←1
	ACCUMULATORS{B,C}
	LAC 1,BUFFER↔CDR 2,-1(1)	;BUFFER SIZE.
	ADDI 2,-1(1)↔DAC 2,BUFEND
	ADDI 1,2↔DAC 1,BUFHD		;POINT TO THIRD WORD.
	SETZM IGNORE
	SETZM SIZBRT
CLR2:	LAC A,BUFHD			;BLIT III-TEXT OPCODE-1 THRU THE BUFFER.
	MOVEI B,1↔DAC B,1(A)
	MOVEI B,2(A)↔HRLI B,1(A)
	BLT B,@BUFEND
	PUSH P,(P)↔GO LV3
ENDR DPYSET;---------------------------------------------------------

SUBR(DPYBIG,SIZE)	;SET CHARACTER SIZE.
COMMENT .-----------------------------------------------------------.
	LAC SIZE
	DPB [POINT 3,SIZBRT,27]		;REMEMBER NEW SIZE
	POP1J
ENDR DPYBIG;---------------------------------------------------------

SUBR(DPYBRT,SIZE)	;SET BRIGHTNESS.
COMMENT .-----------------------------------------------------------.
	LAC SIZE
	DPB [POINT 3,SIZBRT,24]	;REMEMBER NEW BRIGHTNESS
	POP1J
ENDR DPYBRT;---------------------------------------------------------
;SUBRS AVECT,AIVECT,RVECT,RIVECT	;Vectors
COMMENT ⊗
	TEXT DISPLAY WORD:	 ASCII/ABCDE/ + 1
	LONG VECTOR  WORD:  BYTE(11)X,Y(3)BRT,SIZ(7)OPCODE ⊗

	SUBR(RIVECT)
		GO RIV.	↔ENDR RIVECT
	SUBR(RVECT)
		GO RV.	↔ENDR RVECT
	SUBR(AIVECT)
		GO AIV.	↔ENDR AIVECT
	SUBR(AVECT)
		GO AV.	↔ENDR AVECT

;USES AC 1-3
;DTYO DEPENDS ON THIS
RIV.:	SKIPA  3,[046]		;RELATIVE INVISIBLE VECTOR.
RV.:	MOVEI  3, 006 ↔GO LV0	;RELATIVE   VISIBLE VECTOR.
AIV.:	SKIPA  3,[146]		;ABSOLUTE INVISIBLE VECTOR.
AV.:	MOVEI  3, 106		;ABSOLUTE   VISIBLE VECTOR.
	SETZM DPYCOL		;RESET TAB LOCATION

LV0:	SKIPGE IGNORE↔POP2J
LV:	LAC 1,-2(P)↔LAC 2,-1(P)		;PICKUP X AND Y.
LVC:	DPB 1,[POINT 11,3,10]		;PACK X INTO III-WORD.
	DPB 2,[POINT 11,3,21]		;PACK Y INTO III-WORD.
	SKIPE 1,SIZBRT			;NEW BRIGHTNESS OR SIZE?
	GO [ IOR 3,1↔SETZM SIZBRT↔GO LV2]	;YES, SET IT
LV2:	AOS 1,DPYPTR↔DAC 3,(1)		;PACK WORD INTO III-BUFFER.
LV3:	HRLI 1,<(<POINT 7,0,35>)>	;UPDATE DPYPTR...
	DAC 1,DPYPTR↔MOVEI 1,(1)		;WHICH IS A BYTE-POINTER.
	CAML 1,BUFEND↔SETOM IGNORE	;CHECK FOR BUFFER OVERFLOW.
	POP2J
SUBR(DPYSTR,TEXT)
COMMENT .-----------------------------------------------------------.
;USES AC 1,3
	SKIPE IGNORE↔POP1J
	LAC 3,TEXT↔HRLI 3,440700
L1:	ILDB 3↔JUMPE POP1J.
	CALL(DTYO,0)↔GO L1
ENDR DPYSTR;---------------------------------------------------------

SUBR(DTYO,CHAR)
COMMENT .-----------------------------------------------------------.
;USES AC 1
;DPYSTR DEPENDS ON DTYO NOT CLOBBERING 3
	SKIPE IGNORE↔POP1J
	SKIPE SIZBRT
	GO [ PUSHP 0↔PUSHP 2↔PUSHP 3
	     CALL(RIVECT,[0],[0])
	     POPP 3↔POPP 2↔POPP 0
	     GO .+1]
	LAC 1,CHAR
	CAIN 1,15↔SETOM DPYCOL
	CAIN 1,11↔GO DOTAB
DTYO1:	IDPB 1,DPYPTR↔AOS DPYCOL
	CDR 1,DPYPTR↔CAML 1,BUFEND
	SETOM IGNORE↔POP1J
DOTAB:	CALL(DTYO,[" "])	;We got a tab, put out spaces until
	LAC 1,DPYCOL		;column is divisible by 8
	TRNE 1,7↔GO DOTAB
	CDR 1,DPYPTR
	POP1J
ENDR DTYO;-----------------------------------------------------------

SUBR(DPYOUT,POG)
COMMENT .-----------------------------------------------------------.
	.LOAD SYS:NETDPY.REL
	A←←1
	ACCUMULATORS{B,C}
	SKIPN A,BUFHD↔GO L1
	LAC 2,DPYPTR↔DAC 2,-2(1)
	MOVEI 2,2(2)↔SUB 2,1↔DAC 2,-1(1)

L1:	CDR B,DPYPTR↔SUB B,BUFHD		;BUFFER LENGTH.
	AOS B↔DAC B,BUFHD+1

	MOVM A,POG↔DPB A,[POINT 4,UPGOP,12]	;GLASS TO AC FIELD.
	PUSHJ P,NETDPY↑
	XCT UPGOP
	POP1J
UPGOP:	703B8+BUFHD
ENDR DPYOUT;---------------------------------------------------------
;SUBRS OCTDPY,DECDPY,FLODPY	;Numeric display
;--------------------------------------------------------------------

SUBR(OCTDPY,INTEGER)	;OCTAL NUMBER DISPLAY.
	Q←15 ↔ N←13
	JFCL↔GO L2
	LAC 14,INTEGER↔LAC Q,[POINT 3,14,-1]↔MOVEI N,6
L1:	ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L1
	CALL(DTYO,[" "])
L2:	LAC 14,INTEGER↔LAC Q,[POINT 3,14,17]↔MOVEI N,6
L3:	ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L3
	POP1J
ENDR OCTDPY;3/25/73(BGB)---------------------------------------------

DECDPY↑:;(INTEGER)	;DECIMAL NUMBER DISPLAY.
BEGIN DECDPY
	LAC 1,-1(P)↔POP P,-1(P)		;FETCH ARG AND LAC RET. ADR.
L1:	JUMPGE 1,L2			;TEST FOR NEGATIVE NUMBER.
	MOVM 2,1↔CALL(DTYO,["-"])	;PRINT MINUS SIGN.
	LAC 1,2
L2:	IDIVI 1,12↔PUSH P,2		;MODULO TEN AND SAVE.
	SKIPE 1↔PUSHJ P,L2		;TEST FOR DONE.
	POP P,1↔ADDI 1,60↔CALL(DTYO,1)	;RESTORE & PRINT.
	POPJ P,
BEND DECDPY;12/17/72(BGB)--------------------------------------------

SUBR(FLODPY,FLONUM,PLACES)	;FLOATING NUMBER DISPLAY.
	LAC FLONUM
	JUMPL[CALL(DTYO,["-"])↔MOVM FLONUM↔GO .+1]
	MOVM 2,PLACES↔CAILE 2,6↔MOVEI 2,6↔DAC 2,PLACES
	FMPR[1.↔10.↔100.↔1000.↔10000.↔100000.↔1000000.](2)↔FIXX
	IDIV[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	PUSHP 1↔CALL(DECDPY,0)↔POPP 0
	LAC 2,PLACES
	ADD[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	PUSHP DPYPTR↔CALL(DECDPY,0)↔POPP 1
	MOVEI "."↔IDPB 0,1
	POP2J
ENDR FLODPY;12/17/72(BGB)--------------------------------------------
;TITLE MEMORY MANAGEMENT - BGB - FEBRUARY 1974.

;UNIVERSE TOP STRUCTURE.
;--------------------------------------------------------------------
OLD44↑:	0	;ORIGINAL JOBREL 44 CONTENTS.
UNIVER↑:0	;POINTER TO UNIVERSE NODE.
BLKCNT↑:0	;NUMBER OF NON EMPTY NODES.
AVAIL↑:	0	;POINTER TO FIRST EMPTY NODE.
NODSIZ←←=12	;NUMBER OF WORDS PER NODE.
MINLINK←←-3	;LOWEST NUMBERED LINK.
REMAINDER:0	;NUMBER OF UNUSED WORDS BETWEEN 
		; THE TOP OF NODE SPACE AND THE TOP OF CORE.
;--------------------------------------------------------------------
;SAIL COMPATIBLITY ROUTINES.
;--------------------------------------------------------------------
;SAIL ACCUMULATORS PROTECTED: 12,16,17.
IFN SAIL{
ENTRY.↑: 0					;SAIL TO GEM.
	DAC 12,SAIL12
	DAC 16,SAIL16
	GO@ENTRY.
EXIT.↑:	0					;GEM TO SAIL.
	DAC 1,RESULT↑		;GLOBAL RESULT VALUE.
	LAC 12,SAIL12
	LAC 16,SAIL16
	GO@EXIT.
SAIL12↑:0
SAIL16↑:0
ENTERS↑:-1
LIT}
;--------------------------------------------------------------------
IFN SAIL{
INTERN CAR,CDR,DIP,DAP
CAR:	LAC 1,-1(P)↔CAR 1,(1)↔SUB P,[2(2)]↔GO@2(P)
CDR:	LAC 1,-1(P)↔CDR 1,(1)↔SUB P,[2(2)]↔GO@2(P)
DIP:	LAC -2(P)↔LAC 1,-1(P)↔DIP 0,(1)↔SUB P,[3(3)]↔GO@3(P)
DAP:	LAC -2(P)↔LAC 1,-1(P)↔DAP 0,(1)↔SUB P,[3(3)]↔GO@3(P)
}
;LISP COMPATIBLITY ROUTINES.
;--------------------------------------------------------------------
;LISP ACCUMULATORS PROTECTED: 0,14,15,16,17.
IFN LISP{
DEFINE NUMVAL(AC){
	TRNE AC,400000↔GO .+4
	CDR AC,(AC)↔CDR AC,(AC)↔SKIPA AC,(AC)
	SUBI AC,577777}
ENTRY.↑:0				;LISP TO GEM.
	DAC 0,LISP0↔LAC[XWD 5,LISP0+5]
	BLT 0,LISP0+17↔LAC 17,14	;USE LISP PDL.
	CDR ENTRY.↔SUBI 3↔CAR@↔ANDI 7	;NUMBER OF ARGUMENTS.
	JUMPE @ENTRY.
	NUMVAL(1)↔PUSH P,1↔SOSG↔PUSHJ P,@ENTRY.
	NUMVAL(2)↔PUSH P,2↔SOSG↔PUSHJ P,@ENTRY.
	NUMVAL(3)↔PUSH P,3↔SOSG↔PUSHJ P,@ENTRY.
	NUMVAL(4)↔PUSH P,4↔SOSG↔PUSHJ P,@ENTRY.
	SKIPA
EXIT.↑:	0				;GEM TO LISP.
	LAC 0,[XWD LISP0+5,5]↔BLT 0,17
	LAC  0,LISP0
	TLNE 1,-1↔GO MAKNUM↑		;FLONUM.
	GO MAKNUM+1			;FIXNUM.
ENTERS↑: -1↔LISP0:BLOCK 20}
;--------------------------------------------------------------------
SUBR(MKUNIV)		;MAKE UNIVERSE.
COMMENT .-----------------------------------------------------------.
	CALL(MORCOR)			;MAKE UNIVERSE NODE.
	SETQ(WORLD,{MKWORLD})		;MAKE A WORLD  FOR THIS UNIVERSE.
	SETQ(CAMERA,{MKCAMERA,WORLD})	;MAKE A CAMERA FOR THIS WORLD.
	CALL(MKWINDOW,CAMERA,[0])	;MAKE A WINDOW FOR THIS CAMERA.
	POP0J
DECLARE{WORLD,CAMERA}
ENDR MKUNIV;7/12/73(BGB)---------------------------------------------

SUBR(MKWORLD)		;MAKE A WORLD NODE.
COMMENT .-----------------------------------------------------------.
	SETQ(WORLD#,{MKNODE,[$WORLD]})
	CW. 1,1↔CCW. 1,1		;EMPTY BODY RING.
	BRO. 1,1↔SIS. 1,1		;WORLD RING.
	CALL(MKFRAME↑)			;WORLD FRAME OF REFERENCE.
	LAC 2,WORLD
	FRAME. 1,2

;PLACE NEW WORLD AT THE END OF THE WORLD RING.
	LAC 1,WORLD
	LAC 4,UNIVERSE↔PWRLD 2,4  ;GET FIRST WORLD OF THIS UNIVERSE.
 	JUMPN 2,[BRO  3,2
	BRO. 1,2↔SIS. 2,1	;RING-IN THE NEW WORLD.
	SIS. 1,3↔BRO. 3,1↔GO .+3]
	NWRLD. 1,4↔PWRLD. 1,4	;INIT THE UNIVERSE'S WORLD RING.

;MAKE A SUN FOR THIS WORLD.
 	SETQ(SUN#,{MKCAMERA,[0]})	;MAKE A SUN (LIKE A CAMERA).
	MOVEI $SUN↔DAP(1)		;MARK THE NODE AS SUN TYPE.
	FRAME 2,1↔LAC[100.0]↔DAC ZWC(2)	;PLACE SUN A HUNDRED FEET UP.
	LAC 2,WORLD↔ALT. 1,2↔PWRLD. 2,1	;PLACE THE SUN IN THE WORLD.

;RETURN WORLD.
	LAC 1,WORLD↔POP0J
ENDR MKWORLD;3/12/73(BGB)--------------------------------------------
SUBR(MKCAMERA,WORLD)
COMMENT .------------------------------------------------------------
If WORLD argument is not zero then place camera in world's camera ring.
	SETQ(CAMERA#,{MKNODE,[$CAMERA]})
	BRO. 1,1↔SIS. 1,1		;CAMERA RING.
	SKIPE 2,WORLD↔PWRLD. 2,1	;CAMERA POINTS AT ITS WORLD.

;DEFAULT PHYSICAL RASTER SIZE.
	DEFINE MM{3.280833E-3}
	DEFINE MICRON{3.280833E-6}
	LAC[38.78]↔FMPR[MICRON]↔DAC 1(1)	;PDX.
	LAC[40.00]↔FMPR[MICRON]↔DAC 2(1)	;PDY.
	LAC[12.50]↔FMPR[MM]↔    DAC 3(1)	;FOCAL
	LAC[XWD =288,=216]↔DAC 8(1)	;COLUMNS,,ROWS.	;LDX,,LDY

	MOVN 3(1)↔FDVR 1(1)↔DAC -3(1)		;SCALEX ← -FOCAL/PDX
	MOVN 3(1)↔FDVR 2(1)↔DAC -2(1)		;SCALEY ← -FOCAL/PDY
	MOVN 3(1)↔FDVR 2(1)↔DAC -1(1)		;SCALEZ ← -FOCAL/PDZ

;CAMERA LOCUS AND ORIENTATION.

	CALL(MKFRAME↑)
	LAC[16.0]↔DAC ZWC(1)		;16 FEET ABOVE XY PLANE.
	LAC 2,CAMERA↔FRAME. 1,2

;PLACE NEW CAMERA AT THE END OF THE WORLD'S CAMERA RING.
	LAC 1,CAMERA
	LAC 4,WORLD↔PCAMR 2,4  ;GET FIRST CAMERA OF THIS WORLD.
 	JUMPN 2,.+4
	NCAMR. 1,4↔PCAMR. 1,4	;INIT THE WORLD'S CAMERA RING.
	POP1J
	BRO  3,2
	BRO. 1,2↔SIS. 2,1	;RING-IN THE NEW CAMERA.
	SIS. 1,3↔BRO. 3,1↔POP1J
ENDR MKCAMERA;3/12/73(BGB)-------------------------------------------
SUBR(MKWINDOW,CAMERA,WINDOW)	;MAKE AND LINK A WINDOW NODE.
COMMENT .------------------------------------------------------------
CAMERA argument may be zero;
Zero WINDOW argument will cause a new Display ring;
Otherwise new window placed into the display ring of the given window.

	CALL(MKNODE,[$WINDOW])			;WINDOW CREATION.
	LAC[3.5]↔DAC -1(1)			;MAGNIFICATION.
	LAC[XWD -=511,=511]↔DAC 1(1)		;XWD XL,,XH
	LAC[XWD -=384,=384]↔DAC 2(1)		;XWD YL,,YH
	LAC CAMERA↔NCAMR. 0,1			;POINTER TO CAMERA.
	BRO. 1,1↔SIS. 1,1			;WINDOW RING.
	CW.  1,1↔CCW. 1,1			;DISPLAY RING.

;PLACE NEW WINDOW IN DISPLAY RING NEXT TO GIVEN WINDOW.

	SKIPN 2,WINDOW↔GO L1
	PVT 0,2↔AOS↔PVT. 0,1	;INCREMENT SERIAL NUMBER.
	SIS 3,2
	SIS. 1,2↔BRO. 2,1
	BRO. 1,3↔SIS. 3,1↔POP2J

;PLACE NEW WINDOW IN BRAND NEW DISPLAY RING, ALL BY ITSELF.
L1:	AOS 3(1)		;SERIAL NUMBER #1.
	LAC 4,UNIVERSE↔CCW 2,4	;GET FIRST DISPLAY RING.
	CW. 1,4↔CCW. 1,4	;UPDATE UNIVERSE NODE.
	JUMPE 2,POP2J.		;EXIT WHEN FIRST DISPLAY RING.
	CW 3,2
	CW. 1,2↔CCW. 2,1	;RING-IN A NEW DISPLAY RING.
	CCW. 1,3↔CW. 3,1
	POP2J

ENDR MKWINDOW;3/12/73(BGB)-------------------------------------------
	;FAIL MORE CORE.
IFE SAIL{
SUBR(MORCOR)
COMMENT .-----------------------------------------------------------.

;INITIALIZE THE UNIVERSE NODE WHEN NECESSARY.
	SKIPE UNIVERSE↔GO L1		;SKIP ON FIRST TIME ONLY.
	SKIPE 1,OLD44↔CORE 1,↔JFCL	;CORE DOWN.
	LAC 1,JOBREL↑↔DAC 1,OLD44	;SAVE JOBREL.
	SETZM REMAINDER
	ADDI 1,4↔DAC 1,UNIVERSE
L1:	LAC 1,UNIVERSE
	MOVEI -1(1)↔DAC BLKCNT#		;POINTER TO NODES COUNTER.
	MOVEI  1(1)↔DAC AVAIL#		;POINTER TO AVAIL LIST.

;FOUR MORE K.
	LAC 1,JOBREL↔LAC JOBREL↔ADDI 10000
	CORE↔FATAL<NO MORE CORE>
	AOS 1↔SUB 1,REMAINDER
	DAC 2,AC2#↔LAC 2,JOBREL
	SETZM(1)↔HRLI(1)↔HRRI(1)1↔BLT(2)
	MOVEI 2↔DAP @UNIVERSE		;UNIVERSE NODE IS TYPE #2.

;MAKE AVAIL LIST.
	DIP 1,1↔ADD 1,[XWD NODSIZ+3,3]	;XWD NEXT,,THIS.
	SKIPN@BLKCNT↔GO[
	  ADD 1,[XWD NODSIZ,NODSIZ]	;STEP OVER THE UNIVERSE NODE.
	  AOS@BLKCNT↔GO .+1]		;COUNT THE UNIVERSE NODE.
	HRRZM 1,@AVAIL
L2:	HLRZM 1,1(1)↔AOS(1)		;EMPTY LINK & EMPTY NODE TYPE #1.
	ADD 1,[XWD NODSIZ,NODSIZ]	;ADVANCE ONE NODE.
	CAILE 2,NODSIZ+NODSIZ-1-3(1)	;TEST FOR LAST NODE BUT ONE.
	GO L2↔AOS(1)
;COMPUTE CORE REMAINDER.
	SUBI 2,NODSIZ-1-3(1)↔DAC 2,REMAINDER
	MOVEI 10000↔LAC 1,UNIVER↔ADDM -3(1)	;CORE SIZE.
	LAC 1,@AVAIL↔LAC 2,AC2↔POP0J
ENDR MORCOR;4-DEC-72(BGB)
}
	;SAIL MORE CORE.
IFN SAIL{
SUBR(MORCOR)------------------------------------------------------
	ACCUMULATORS{PTR,SIZ}

;GET MORE CORE FROM SAIL - BGB - 8 MARCH 1972.
	PUSH P,PTR↔PUSH P,SIZ↔SETZ PTR,
L1:	MOVEI SIZ,NODSIZ*=400+1		;AC3 SIZE OF SPACE.
	CALL(CORGET↑)			;AC2 ADDRESS OF SPACE.
	GO[FATAL(NO MORE CORE.)]↔SOS SIZ
	MOVSI(PTR)↔HRRI 1(PTR)↔SETZM(PTR) ;CLEAR 4K BLOCK OF MEMORY.
	BLT NODSIZ*=400-1(PTR)		  ;CLEAR 4K BLOCK OF MEMORY.
	LAC 1,PTR			  ;-3 WORD OF FIRST NODE.

;INITIALIZE THE UNIVERSE WHEN NECESSARY.
	SKIPE 2,UNIVER↔GO L3↔LAC 2,1
	ADDI 2,3↔DAC 2,UNIVERSE		;POINTER TO UNIVERSE NODE.
	MOVEI 2↔DAP @UNIVERSE		;UNIVERSE NODE IS TYPE #2.
L3:	MOVEI -1(2)↔DAC BLKCNT#		;POINTER TO NODES COUNTER.
	MOVEI  1(2)↔DAC AVAIL#		;POINTER TO AVAIL LIST.

;MAKE AVAIL LIST.
	DIP 1,1↔ADD 1,[XWD NODSIZ+3,3]		;XWD NEXT,,THIS
	SKIPN @BLKCNT↔GO[
	  ADD 1,[XWD NODSIZ,NODSIZ]     	;STEP OVER UNIVERSE.
	  AOS @BLKCNT↔SUBI SIZ,NODSIZ↔GO .+1]	;COUNT UNIVERSE NODE.
	SUBI SIZ,NODSIZ				;ALL BUT THE LAST.
	HRRZM 1,@AVAIL				;FIRST AVAIL NODE.

;PLACE EACH NEW EMPTY BLOCK ON THE AVAIL LIST.
L2:	HLRZM 1,1(1)↔AOS(1)		;EMPTY LIST POINTER & TYPE #1.
	ADD 1,[XWD NODSIZ,NODSIZ]
	SUBI SIZ,NODSIZ
	JUMPG SIZ,L2↔AOS(1)		;LAST AVAIL NODE.
	LAC 1,@AVAIL			;FIRST AVAIL NODE.
	POP P,3↔POP P,2↔POP0J
ENDR MORCOR;------------------------------------------------------
}
SUBR(MKNODE,NODTYP)		;ALLOCATE A BLOCK OF NODSIZ WORDS.
COMMENT .-----------------------------------------------------------.
	LAC 1,UNIVERSE↔AOS -1(1)	;COUNT OF NODES IN USE.
	MOVEI 1,1(1)↔DAC 1,TMP1#	;POINTER TO AVAIL LIST.
	SKIPN 1,0(1)↔CALL(MORCOR)	;EMPTY AVAIL LIST.
	CDR 1(1)↔DAP @TMP1		;NEXT AVAILABLE NODE.
	SETZM 1(1)			;CLEAR THIS NODE.
	LAC NODTYP↔DAC(1)↔POP1J		;PLACE NODE TYPE BITS.
ENDR MKNODE;2/22/74(BGB)---------------------------------------------

SUBR(KLNODE,NODE)		;RELEASE  BLOCK OF NODSIZ WORDS.
COMMENT .-----------------------------------------------------------.
	SKIPN 1,NODE↔POP1J		;WOULDN'T KILL NIL.
	LAC(1)↔CAIN 0,1			;TEST FOR EMPTY NODE.
	GO[FATAL(KILLING EMPTY NODE.)]	;CAN'T KILL AN EMPTY.
	HRLI -3(1)↔HRRI -2(1)		;CLEAR NODE.
	SETZM -3(1)↔BLT 8(1)↔AOS(1)	;MARK NODE TYPE EMPTY-1.
	LAC UNIVERSE↔SOS↔SOS@↔ADDI 2	;COUNT OF NODES IN USE.
	HRL 1,@↔HLRZM 1,1(1)↔HRRZM 1,@	;CONS NODE INTO AVAIL LIST.
	POP1J
ENDR KLNODE;2/22/74(BGB)---------------------------------------------
;TITLE IO - INPUT/OUTPUT - BGB - FEBRUARY 1973.
	EXTERN MKF,MKE,MKV,MKB
	↓CMDCHN←←16
	↓IODEND←20000
	FILNAM:0	;FILE NAME.
	EXTION:0↔0	;EXTENSION.
	PPPN:0		;PROJECT-PROGRAMMER.
	STRING:	0	;SAIL STRING BYTE POINTER.
	STRCNT: -1	;SAIL STRING CHAR COUNT.
	
	OBUF:BLOCK 3	;OUTPUT BUFFER HEADER.
	IBUF:BLOCK 3	;INPUT BUFFER HEADER.
	IOBUF:	BLOCK 2*(201+2)

	CMDHDR:	BLOCK 3	;COMMAND BUFFER HEADER
	CMDBUF:	BLOCK 2*(201+2)

	FILFLG↑:0	;COMMAND FILE
	EOF:	0	;END OF FILE FLAG.
	GEMFLG:	0	;KIND OF FILE FORMAT: 0 FOR B3D, -1 FOR GEM.
	GEMASK:	400417000077 ;IGNORED STATUS BITS ON GEM INPUT.

	BLOCK 3
	BFRAME:BLOCK 9	;BODY FRAME BUFFER.
	
	PCNT:0		;PARTS COUNT.
	FCNT:0		;FACE COUNT.
	ECNT:0		;EDGE COUNT.
	VCNT:0		;VERTEX COUNT.

	PLTFLG↑: 0	;SET DURING PLOT OUTPUT TO DISABLE III KLUDGES

SUBN(WORDO,WORD)	;WORD OUTPUT.
COMMENT .-----------------------------------------------------------.
	LAC WORD
	SOSG OBUF+2↔OUT 1,0
	GO[IDPB 0,OBUF+1↔POP1J]
	FATAL(WORDO)
ENDR;2/18/73(BGB)----------------------------------------------------

WORDIN: ;----------------------------------------------------------
BEGIN WORDIN; WORD INPUT TO AC0 - BGB - 18 FEBRUARY 1973.
	SOSG IBUF+2↔IN 1,0
	GO[ILDB 0,IBUF+1↔POPJ P,]
	STATO 1,1B22↔GO[FATAL(WORDIN)]
	SETZ↔SETOM EOF↔POPJ P,
BEND;2/18/73(BGB)--------------------------------------------------
SUBR(PLOTO)SAISTR	;DISPLAY BUFFER TO DISK FILE.
COMMENT .-----------------------------------------------------------.
	CALL(GETFIL,[SIXBIT/PLT/])↔POP0J
	LAC 1,DPYBUF↑↔MOVN(1)1↔SUBI 2
	CDR 2,(1)↔SETZM 1(2)
	MOVS↔HRRI -1(1)↔DAC DUMLST
	INIT 1,17↔SIXBIT/DSK/↔0↔HALT
	ENTER 1,FILNAM↔GO .+4
	OUT 1,DUMLST↔JFCL
	RELEASE 1,↔POP0J
DUMLST:	0↔0
ENDR PLOTO;12/10/72(BGB)---------------------------------------------
SUBR(TVHELP,FILLOC)	;HELP - DISPLAY DOCUMENTATION.
COMMENT .-----------------------------------------------------------.
	SETZM INHDR
	INIT 17,↔SIXBIT/DSK/↔INHDR
	GO [FATAL(CAN'T INIT DSK)]
	MOVEI 1,2↔HRL 1,FILLOC↔BLT 1,5
	LOOKUP 17,2↔GO[OUTSTR[ASCIZ/HELP FILE NOT FOUND.
/]↔     POP1J ]
	PUSH P,JOBFF↑↔PUSH P,JOBREL↑↔LAC 1,JOBREL↔DAC 1,JOBFF
	USETI 17,1↔SETSTS 17,0↔MOVEI 0,4↔GO PGLOOP-1 ;START 'EM ON PAGE-4.
LOOP:	USETI 17,1↔SETSTS 17,0↔OUTSTR[ASCIZ/PAGE = /]		
	CALL(REALI)↔FIXX↔JUMPE 0,RET↔DAC 0,PAGNUM#
	SOJLE 0,FOUND
PGLOOP:	CALL(GETCHR)↔GO[OUTSTR[ASCIZ/PAGE NOT FOUND.
/]↔     GO RET]
	CAIE 1,14↔GO PGLOOP↔GO PGLOOP-1

FOUND:	CALL(DPYSET,DPYBUF)↔CALL(AIVECT,[0],[=440])
	CALL(DPYBIG,[1])↔CALL(DPYBRT,[1])↔SETZM LPOS#

CHLOOP:	CALL(GETCHR)↔GO FIN
	CAIN 1,14↔GO FIN
	CAIN 1,11↔GO[CALL(DTYO,[40])
	     AOS 1,LPOS↔TRNE 1,7↔GO $.-4↔GO CHLOOP]
	CALL(DTYO,1)↔AOS LPOS↔LAC 1,1(P)
	CAIE 1,15↔GO CHLOOP
	SETZM LPOS↔CALL(RIVECT,[1000],[0])
	GO CHLOOP

FIN:	CALL(DPYOUT,[16])↔GO LOOP
RET:	RELEASE 17,↔POP P,JOBFF↔LAC 1,JOBFF
	CORE 1,↔GO[FATAL(CAN'T SHRINK CORE)]
	POP P,JOBFF↔POP1J
GETCHR:	SOSG INHDR+2↔IN 17,
	GO[ILDB 1,INHDR+1↔AOS(P)↔POP0J ]	;SKIP ON CHARACTER.
	POP0J
INHDR:	BLOCK 3
ENDR TVHELP;---------------------------------------------------------
SUBN(GETFIL,EXT)	;SETUP FILE SPEC FROM TTY LINE.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{PTR,CNT}
	SETZM FILNAM↔SETZM EXTION		;CLEAR FILNAME BLOCK.
	SETZM EXTION+1↔SETZM PPPN

	IFN SAIL{LAC 16,SAIL16↑↔POP 16,STRING	;SAIL STRING ARGUMENT.
	POP 16,0↔HRRZM STRCNT↔DAC 16,SAIL16↑↔SKIPLE STRCNT↔GO L0}

	IFN LISP{}

;TYPE OUT DEFAULT EXTENSION AND "FILE = ".
	OUTCHR[9]↔LAC 1,EXT↔JUMPE 1,.+6
	SETZ↔ROTC 6↔ADDI 40↔OUTCHR↔GO .-5
	OUTSTR[ASCIZ/ FILE = /]

;FIRST CHARACTER.
L0:	LAC PTR,[POINT 6,FILNAM,-1]
	MOVEI CNT,6				;BYTE PTR AND CHR COUNT.
	CALL(GETCHL)↔DAC 1,0
	CAIL "a"↔SUBI 40
	CAIN 15↔GO[CALL(GETCHL)↔POP1J]↔AOSA(P)	;SKIP FILE NAME GIVEN.

;SCAN FOR FILENAME DELIMITERS.
L:	CALL(GETCHL)↔DAC 1,0↔CAIL "a"↔SUBI 40
	CAIN "."↔GO[SETZM EXT↔LAC PTR,[POINT 6,EXTION,-1]↔MOVEI CNT,3↔GO L]
	CAIN "["↔GO[LAC PTR,[POINT 6,PPPN,-1]↔MOVEI CNT,3↔GO L]
	CAIN ","↔GO[LAC PTR,[POINT 6,PPPN,17]↔MOVEI CNT,3↔GO L]
	CAIN "]"↔GO L
	CAIN 15↔GO EOL↔CAIN 12↔GO EOL	;END OF THE LINE.
	JUMPE EOL+1			;NULL CHARACTER - AT END OF SAIL STRINGS.
	CAIG " "↔GO L			;IGNORE GARBAGE.
	SOJL CNT,L
	SUBI 40↔IDPB PTR↔GO L		;ASCII TO SIXBIT.

;RIGHT ADJUST SHORT PPPN'S.
EOL:	CALL(GETCHL)↔CAR PPPN
	TRNN 77↔LSH -6↔TRNN 77↔LSH -6	;RIGHT ADJUST PROJECT.
	DIP PPPN↔CDR PPPN
	TRNN 77↔LSH -6↔TRNN 77↔LSH -6	;RIGHT ADJUST PROGRAMMER.
	DAP PPPN
	SKIPN 1,EXTION↔LAC 1,EXT	;DEFAULT EXTENSION.
	DAC 1,EXTION↔POP1J
ENDR GETFIL;2/18/73(BGB)---------------------------------------------
SUBR(GETCHW)		;GET CHARACTER WAIT.
COMMENT .-----------------------------------------------------------.
IFN SAIL{SKIPL STRCNT↔GO[SOSGE STRCNT↔TDCA 1,1↔ILDB 1,STRING↔POP0J]}
	SKIPE FILFLG↔CALL(FILCHR)↔INCHRW 1↔POP0J
ENDR GETCHW;2/23/74(BGB)---------------------------------------------

SUBR(GETCHL)
COMMENT .-----------------------------------------------------------.
IFN SAIL{SKIPL STRCNT↔GO[SOSGE STRCNT↔TDCA 1,1↔ILDB 1,STRING↔POP0J]}
	SKIPE FILFLG↔CALL(FILCHR)↔INCHWL 1↔POP0J
ENDR GETCHL;2/23/74(BGB)---------------------------------------------

SUBN(FILCHR)		;GET FILE CHARACTER & SKIP.
COMMENT .-----------------------------------------------------------.
	SOSG CMDHDR+2↔IN CMDCHN,
	GO[ILDB 1,CMDHDR+1↔JUMPE 1,FILCHR↔AOS(P)↔POP0J ]
	STATO CMDCHN,IODEND↔FATAL(READ ERROR IN COMMAND FILE)
	RELEASE CMDCHN,
	SETZB 1,FILFLG↔POP0J
ENDR FILCHR;2/23/74(BGB)---------------------------------------------

SUBN(SERIAL,BODY)	;SERIAL NUMBER THE FEV OF A BODY FOR OUTPUT.
COMMENT .-----------------------------------------------------------.
	LAC 1,BODY↔TEST 1,BBIT↔POP1J

;COUNT FACES, EDGES, AND VERTICES.
	MOVEI 1↔PFACE 1,1↔ALT. 0,1↔CAME 1,BODY↔AOJA .-3↔SOS↔DAC FCNT
	MOVEI 1↔PED   1,1↔ALT. 0,1↔CAME 1,BODY↔AOJA .-3↔SOS↔DAC ECNT
	MOVEI 1↔PVT   1,1↔ALT. 0,1↔CAME 1,BODY↔AOJA .-3↔SOS↔DAC VCNT

;COUNT PARTS.
	SETZ↔SON 1,1↔DAC 1,2↔JUMPE 1,.+5↔AOS
	BRO 2,2↔CAME 1,2↔AOJA .-2
	DAC PCNT

;OUTPUT BODY HEADER.
	CALL(WORDO,PCNT)
	CALL(WORDO,FCNT)
	CALL(WORDO,ECNT)
	CALL(WORDO,VCNT)
	LAC 1,BODY
	CALL(WORDO,{-2(1)})	;PNAME.
	CALL(WORDO,{-1(1)})	;PNAME.
	SKIPN GEMFLG↔GO L0
	CALL(WORDO,{0(1)})	;BODY TYPE BITS.
	CALL(WORDO,{8(1)})	;USER'S BODY WORD.

;BODIES LOCATION ORIENTATION MATRIX.
L0:	FRAME 1,1↔SKIPN 1↔MOVEI 1,L2		;BODY'S FRAME OR EMPTY.
	MOVEI 2,=12↔SUBI 1,3
L1:	CALL(WORDO,{(1)})↔AOS 1↔SOJG 2,L1
	POP1J
;EMPTY FRAME.
	0↔0↔0
L2:	1.0↔0↔0↔ 0↔1.0↔0↔ 0↔0↔1.0
ENDR SERIAL;2/18/73(BGB)---------------------------------------------
SUBN(OFEV,BODY)		;OUTPUT THE FEV OF A BODY.
COMMENT .-----------------------------------------------------------.
	LAC 1,BODY

;FACES.
L1:	PFACE 1,1↔CAMN 1,BODY↔GO L2
	CALL(WORDO,{4(1)})	;FIRST FACE DATA WORD  -  REFLECTIVITIES.
	CALL(WORDO,{5(1)})	;SECOND FACE DATA WORD -  ILLUMINOUSITIES.
	SKIPN GEMFLG↔GO L1
	CALL(WORDO,{0(1)})	;BODY TYPE BITS.
	CALL(WORDO,{8(1)})	;USER'S BODY WORD.
	GO L1

;EDGES.
L2:	PED 1,1↔CAMN 1,BODY↔GO L3	;OUTPUT EDGE NODES.
	NFACE 2,1↔ALT 2,2↔DIP 2,0
	PFACE 2,1↔ALT 2,2↔DAP 2,0↔LAC 2,(1)
	TLNE 2,(DARKEN)↔TLO 1B18
	TLNE 2,(NSHARP)↔TRO 1B18↔CALL(WORDO,0)
	NVT   2,1↔ALT 2,2↔DIP 2,0
	PVT   2,1↔ALT 2,2↔DAP 2,0↔CALL(WORDO,0)
	NCW   2,1↔ALT 2,2↔DIP 2,0
	PCW   2,1↔ALT 2,2↔DAP 2,0↔CALL(WORDO,0)
	NCCW  2,1↔ALT 2,2↔DIP 2,0
	PCCW  2,1↔ALT 2,2↔DAP 2,0↔CALL(WORDO,0)
	SKIPN GEMFLG↔GO L2
	CALL(WORDO,{0(1)})	;BODY TYPE BITS.
	CALL(WORDO,{8(1)})	;USER'S BODY WORD.
	GO L2

;VERTICES.
L3:	PVT 1,1↔CAMN 1,BODY↔POP1J	;OUTPUT VERTEX NODES.
	CALL(WORDO,{XWC(1)})
	CALL(WORDO,{YWC(1)})
	CALL(WORDO,{ZWC(1)})
	SKIPN GEMFLG↔GO L3
	CALL(WORDO,{0(1)})	;BODY TYPE BITS.
	CALL(WORDO,{8(1)})	;USER'S BODY WORD.
	GO L3
ENDR OFEV;2/18/73(BGB)-----------------------------------------------
SUBN(OBODY,BODY)	;OUTPUT BODY AND ITS PARTS.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{N,B}
	CALL(SERIAL,BODY)		;SERIAL NUMBER THE F.E.V.
	CALL(OFEV,BODY)			;OUTPUT THE F.E.V.
	LAC B,BODY
	SON N,B↔JUMPE N,L2		;EXIT - AIN'T GOT NO PARTS.
L1:	PUSHP N↔CALL(OBODY,N)		;RECURSE - ON SUB PARTS.
	POPP N↔LAC B,BODY
	BRO N,N↔SON 0,B
	CAME 0,N↔GO L1
L2:	POP1J
ENDR OBODY;2/18/73(BGB)----------------------------------------------

SUBR(OUTB3D,BODY)	;OUTPUT B3D BODY.
COMMENT .-----------------------------------------------------------.
	LAC 1,BODY↔TEST 1,BBIT↔POP1J		;BODIES ONLY.
	MOVSI'GEM'↔SKIPN GEMFLG↔MOVSI'B3D'	;DEFAULT EXTENSION.
L1:	CALL(GETFIL,0)↔POP1J			;GET FILE NAME.

	INIT 1,10↔SIXBIT/DSK/↔XWD OBUF,0↔HALT
	ENTER 1,FILNAM↔GO[RELEASE 1,
	OUTSTR[ASCIZ/ ENTER FAILED./]↔POP1J]

;SETUP OUTPUT BUFFERS.
	MOVEI IOBUF↔EXCH JOBFF↑
	OUTBUF 1,↔DAC JOBFF

;OUTPUT TRANSFER.
	CALL(OBODY,BODY)

;END OF FILE.
	RELEASE 1,
	POP1J
ENDR OUTB3D;2/18/73(BGB)--------------------------------------------

SUBR(OUTGEM,BODY)	;OUTPUT B3D BODY.
COMMENT .-----------------------------------------------------------.
	SETOM GEMFLG
	CALL(OUTB3D,BODY)
	SETZM GEMFLG
	POP1J
ENDR OUTGEM;2/23/74(BGB)
SUBR(INCAM)		;INPUT CAMERA.
COMMENT .-----------------------------------------------------------.
	C←←10↔R←←11	;CAMERA & FRAME.
	TDZA 1,1
L1:	RELEASE 1,↔CALL(GETFIL,[SIXBIT/CAM/])↔GO[SETZ 1,↔POP0J]
	INIT 1,10↔SIXBIT/DSK/↔IBUF↔HALT
	LOOKUP 1,FILNAM↔GO L1
	MOVEI IOBUF↔EXCH JOBFF
	INBUF 1,↔DAC JOBFF
;FETCH NOW CAMERA.
	LAC C,UNIVERSE↑↔NWRLD C,C
	NCAMR C,C↔FRAME R,C↔CALL(KLNODE↑,R)

;INPUT TRANSFER.
	CALL(WORDIN)↔FMPR FEET↔PUSH P,0	;CX
	CALL(WORDIN)↔FMPR FEET↔PUSH P,0	;CY
	CALL(WORDIN)↔FMPR FEET↔PUSH P,0	;CZ

	CALL(WORDIN)↔PUSH P,0	;PAN
	CALL(WORDIN)↔PUSH P,0	;TILT
	CALL(WORDIN)↔PUSH P,0	;SWING

	CALL(MKROT1↑)↔FRAME. 1,C
	POP P,ZWC(1)↔POP P,YWC(1)↔POP P,XWC(1)
	CALL(WORDIN)↔FMPR FEET↔DAC 1(C)		;PDX
	CALL(WORDIN)↔FMPR FEET↔DAC 2(C)		;PDY
	CALL(WORDIN)↔FMPR FEET↔DAC 3(C)		;PDZ
	CALL(WORDIN)↔FMPR FEET↔DAC 1		;FOCAL
	MOVN 1↔FDVR 1(C)↔DAC -3(C)	;SCALEX
	MOVN 1↔FDVR 2(C)↔DAC -2(C)	;SCALEY
	MOVN 1↔FDVR 3(C)↔DAC -1(C)	;SCALEZ
	DAC  1,3(C)			;FOCAL
	LAC 1,C				;RETURN THE CAMERA.
	RELEASE 1,↔POP0J
FEET:3.280833	;FEET PER METER.
ENDR INCAM;2/21/73(BGB)----------------------------------------------
SUBR(OUTCAM)		;OUTPUT CAMERA.
COMMENT .-----------------------------------------------------------.
	C←←10↔R←←11	;CAMERA & FRAME.
L1:	CALL(GETFIL,[SIXBIT/CAM/])↔POP0J
	INIT 1,10↔SIXBIT/DSK/↔XWD OBUF,0↔HALT
	ENTER 1,FILNAM↔GO[RELEASE 1,
	OUTSTR[ASCIZ/ ENTER FAILED./]↔CRLF↔POP0J]
	MOVEI IOBUF↔EXCH JOBFF↑↔OUTBUF 1,↔DAC JOBFF
;FETCH NOW CAMERA.
	LAC 1,UNIVERSE↑↔NWRLD 1,1
	NCAMR C,1↔FRAME R,C
;OUTPUT TRANSFER.
	LAC -3(R)↔FMPR METERS↔CALL(WORDO,0)	;CX
	LAC -2(R)↔FMPR METERS↔CALL(WORDO,0)	;CY
	LAC -1(R)↔FMPR METERS↔CALL(WORDO,0)	;CZ
	SETQ(TILT,{ACOS↑,{KZ(R)}})↔MOVN KY(R)	;TILT ← ACOS(KZ).
	SETQ(PAN,{ATAN2↑,{KX(R)},0})		;PAN  ← ATAN2(KX,-KY).
	CALL(SIN↑,TILT)↔LAC JZ(R)
	JUMPE 1,.+4↔FDVR 0,1
	SETQ(SWING,{ACOS↑,0})			;SWING ← ACOS(JZ/SIN(TILT))
	CALL(WORDO,PAN)
	CALL(WORDO,TILT)
	CALL(WORDO,SWING)
	LAC 1(C)↔FMPR METERS↔CALL(WORDO,0)	;PDX
	LAC 2(C)↔FMPR METERS↔CALL(WORDO,0)	;PDY
	LAC 2(C)↔FMPR METERS↔CALL(WORDO,0)	;PDZ
	LAC 3(C)↔FMPR METERS↔CALL(WORDO,0)	;FOCAL
	RELEASE 1,↔POP0J
DECLARE{PAN,TILT,SWING}
METERS:	0.3048006		;METERS PER FOOT.
ENDR OUTCAM;2/18/73---------------------------------------------------
SUBN(IFEV,BODY)		;INPUT F.E.V. BLOCKS.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{F,E,V,A,I,J,FACE,EDGE,VERTEX}

;SETUP BASE POINTER TO SERIAL TABLES.
	LAC DPYBUF↑↔ADDI 3↔HRLI I	;INDEXED BY ACCUMULATOR I.
	DAC FACE↔DAC EDGE↔DAC VERTEX
	ADD VERTEX,FCNT
	
;MAKE AND INPUT FACES.
	MOVEI I,1
L1:	CALL(MKF,BODY)↔DAC 1,@FACE
	CALL(WORDIN)↔DAC 4(1)		;FACE REFLECTIVITY.
	CALL(WORDIN)↔DAC 5(1)		;FACE LUMENOSITY.
	SKIPN GEMFLG↔GO L1A
	CALL(WORDIN)↔AND GEMASK↔IORM (1);FACE TYPE BITS.
	CALL(WORDIN)↔DAC 8(1)		;FACE USER WORD.
L1A:	CAME I,FCNT↔AOJA I,L1

;MAKE AND INPUT EDGES.
	MOVEI I,1
L2:	CALL(MKE,BODY)↔DIP 1,@EDGE
	CALL(WORDIN)
	LAC 2,(1)
	TLZE 1B18↔TLO 2,(DARKEN)
	TRZE 1B18↔TLO 2,(NSHARP)
	DAC 2,(1)↔DAC 0,1(1)		;TWO FACES.
	CALL(WORDIN)↔DAC 3(1)		;TWO VERTICES.
	CALL(WORDIN)↔DAC 4(1)		;EDGE'S WINGS.
	CALL(WORDIN)↔DAC 5(1)
	SKIPN GEMFLG↔GO L2A
	CALL(WORDIN)↔AND GEMASK↔IORM (1);EDGE TYPE BITS.
	CALL(WORDIN)↔DAC 8(1)		;EDGE USER WORD.
L2A:	CAME I,ECNT↔AOJA I,L2

;MAKE AND INPUT VERTICES.
	MOVEI I,1
L3:	CALL(MKV,BODY)↔DAP 1,@VERTEX
	CALL(WORDIN)↔DAC XWC(1)		;VERTEX WORLD LOCUS.
	CALL(WORDIN)↔DAC YWC(1)
	CALL(WORDIN)↔DAC ZWC(1)
	SKIPN GEMFLG↔GO L3A
	CALL(WORDIN)↔AND GEMASK↔IOR 0(1);TYPE BITS.
	CALL(WORDIN)↔DAC 8(1)		;FACE USER WORD.
L3A:	CAME I,VCNT↔AOJA I,L3

;CONVERT SERIAL NUMBERS TO NODE ADDRESSES.
	MOVEI J,1
L4:	LAC I,J↔CAR E,@EDGE

	NFACE I,E↔CDR F,@FACE↔NFACE. F,E↔PED. E,F
	PFACE I,E↔CDR F,@FACE↔PFACE. F,E↔PED. E,F
	NVT I,E↔CDR V,@VERTEX↔NVT. V,E↔PED. E,V
	PVT I,E↔CDR V,@VERTEX↔PVT. V,E↔PED. E,V
	NCW I,E↔CAR A,@EDGE↔NCW. A,E
	PCW I,E↔CAR A,@EDGE↔PCW. A,E
	NCCW I,E↔CAR A,@EDGE↔NCCW. A,E
	PCCW I,E↔CAR A,@EDGE↔PCCW. A,E
	CAME J,ECNT↔AOJA J,L4
	POP1J
ENDR IFEV;2/18/73(BGB)-----------------------------------------------
SUBN(IBODY,BODY0)	;INPUT A BODY AND ALL ITS PARTS.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{N,B,B0}

;INPUT BODY HEADER.
	CALL(WORDIN)↔DAC PCNT
	CALL(WORDIN)↔DAC FCNT
	CALL(WORDIN)↔DAC ECNT
	CALL(WORDIN)↔DAC VCNT

;INPUT THE FEV SHELL OF THIS BODY.
	SETQ(B1,{MKB,BODY0})↔LAC B0,BODY0
	JUMPN B0,[CALL(BATT↑,B1,B0)↔GO .+1]
	LAC B,B1
	CALL(WORDIN)↔DAC -2(B)	;PNAME.
	CALL(WORDIN)↔DAC -1(B)	;PNAME.
	SKIPN GEMFLG↔GO L1A
	CALL(WORDIN)↔AND GEMASK↔IORM 0(B)	;BODY TYPE BITS.
	CALL(WORDIN)↔DAC 8(B)			;BODY USER WORD.
L1A:
;INPUT THE LOCATION ORIENTATION OF THIS BODY.

	MOVEI 1,BFRAME-3↔MOVEI 2,=12↔SETZ 4,
L1:	CALL(WORDIN)↔DAC(1)↔IORM 4↔AOS 1↔SOJG 2,L1
	CALL(MKFRAME)↔FRAME. 1,B↔JUMPE 4,.+4
	MOVSI BFRAME-3↔HRRI XWC(1)↔BLT KZ(1)
	SKIPN FCNT↔GO .+3↔CALL(IFEV,B)
	LAC B,B1↔SKIPN BODY0↔DAC B,BODY0 ;RETURN VALUE TO TOP LEVEL.

;INPUT THE PARTS OF THIS BODY.
L2:	SOSGE PCNT↔POP0J
	PUSH P,PCNT↔PUSH P,B
	CALL(IBODY)
	POP P,B↔POP P,PCNT↔GO L2
B1:0
ENDR IBODY;2/18/73(BGB)----------------------------------------------
SUBR(INB3D)		;INPUT B3D FORMAT.
COMMENT .-----------------------------------------------------------.
	TDZA 1,1
L1:	RELEASE 1,
	MOVSI'GEM'↔SKIPN GEMFLG↔MOVSI'B3D'	;GEM OR B3D.

	CALL(GETFIL,0)↔GO[SETZ 1,↔POP0J]
	INIT 1,10↔SIXBIT/DSK/↔IBUF↔HALT
	LOOKUP 1,FILNAM↔GO[
	SKIPG GEMFLG↔GO L1
	OUTSTR[ASCIZ/FILE NOT FOUND./]
	RELEASE 1,↔SETZ 1,↔POP0J] 		;SAILOR'S LOSE HERE.

	HLRE PPPN↔MOVM↔CAIGE =18↔GO[		;IS FILE TOO SHORT.
	OUTSTR[ASCIZ/FILE ISN'T A B3D FILE
/]↔	RELEASE 1,↔SETZ 1,↔POP0J]

;SETUP INPUT BUFFERS.
	MOVEI IOBUF↔EXCH JOBFF
	INBUF 1,↔DAC JOBFF

;INPUT TRANSFER.
	CALL(IBODY,[0])↔POP P,1
	RELEASE 1,↔POP0J
ENDR INB3D;2/18/73(BGB)----------------------------------------------

SUBR(INGEM)	;INPUT GEM BODY.
COMMENT .-----------------------------------------------------------.
	SETOM GEMFLG
	CALL(INB3D)
	SETZM GEMFLG
	POP0J
ENDR INGEM;2/23/74(BGB)
SUBR(INGEO)		;INPUT GEO COMMANDS.
COMMENT .-----------------------------------------------------------.
	TDZA 1,1
L1:	RELEASE CMDCHN,
	CALL(GETFIL,[SIXBIT/GEO/])↔GO[SETZ 1,↔POP0J]
	INIT CMDCHN,0↔SIXBIT/DSK/↔CMDHDR↔HALT
	LOOKUP CMDCHN,FILNAM↔GO L1

;SETUP INPUT BUFFERS.
	MOVEI CMDBUF↔EXCH JOBFF
	INBUF CMDCHN,↔DAC JOBFF
	OUTSTR[ASCIZ/<OPENING COMMAND FILE>
/]↔	SETOM FILFLG
	POP0J
ENDR INGEO;2/18/73(BGB)---------------------------------------------

SUBR(INCRE)		;INPUT CRE NODES.
COMMENT .-----------------------------------------------------------.
L1:	CALL(GETFIL,[SIXBIT/CRE/])↔POP0J
	INIT 1,17↔SIXBIT/DSK/↔0↔HALT
	LOOKUP 1,FILNAM↔GO L1		;FILE LOOKUP.
	LAC PPPN↔HRRI 1B18-1↔DAC INARG	;DUMP COMMAND WORD.
	MOVS PPPN↔MOVMS↔ADDI 1B18	;FILE SIZE.
	IORI 1777↔CORE2			;MAKE UPPER SEGMENT.
	GO[OUTSTR[ASCIZ/	CAN'T GET AN UPPER SEGMENT.
/]↔RELEASE 1,↔POP0J]			;MAKE UPPER SEGMENT.
	IN 1,INARG↔RELEASE 1,		;INPUT TRANSFER.
	CALL(CREIMG↑)			;MAKE PERCEIVED IMAGES.
	SETZ↔CORE2↔HALT↔POP0J		;KILL UPPER SEGMENT.
INARG:0↔0
ENDR INCRE;3/14/73(BGB)----------------------------------------------

SUBR(OUTV2D)		;OUTPUT VECTOR 2-D FILE FOR MAKE VIDEO.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{B,E,F1,F2,V1,QQ7,V2}

;FILE OPENING CEREMONIES.
L1:	CALL(GETFIL,[SIXBIT/V2D/])↔POP0J
	INIT 1,10↔SIXBIT/DSK/↔XWD OBUF,0↔HALT
	ENTER 1,FILNAM↔GO[RELEASE 1,
	  OUTSTR[ASCIZ/ ENTER FAILED./]↔CRLF↔POP0J]
	MOVEI IOBUF↔EXCH JOBFF↑↔OUTBUF 1,↔DAC JOBFF

;CALL OCCULT.
	CALL(TAKE2↑,[0])
	SETZ QQ7,		;BACKGROUND INTENSITY !
	LAC 1,UNIVERSE
	SON 1,1↔DAC 1,WRLD#
	LAC B,1

;FOR ALL THE BODIES OF THE WORLD.
L2:	CCW B,B↔CAMN B,WRLD↔GO[
	  CALL(KLTMPS↑,WRLD)
	  RELEASE 1,↔POP0J]

;FOR ALL THE EDGES OF EACH BODY.
	LAC E,B
L3:	PED E,E↔CAMN E,B↔GO L2
	TEST E,VISIBLE↔GO L3		;VISIBLE.
	PVT V1,E↔NVT V2,E
	PFACE F1,E↔NFACE F2,E

;OUTPUT FIRST PART OF A V2D EDGE BLOCK.
	CALL(WORDO,{1(E)})	;NFACE,,PFACE.
	CALL(WORDO,{XPP(V1)})
	CALL(WORDO,{YPP(V1)})
	CALL(WORDO,{XPP(V2)})
	CALL(WORDO,{YPP(V2)})


;EDGE NOT SHARP - SMOOTH THE FACE INTENSITIES.
	TEST E,NSHARP↔GO L4

	CALL(MIDQQ,{QQ(F1)},{QQ(F2)})
	DAC 1,QQL1↔DAC 1,QQL2
	DAC 1,QQR1↔DAC 1,QQR2

;GOURAUD SHADING.
	NCCW F2,E↔PCW F1,E
	CALL(MIDQQ,{QQ(F1)},{QQ(F2)})
	CALL(MIDQQ,1,QQL1)
	DAC 1,QQL1↔DAC 1,QQR1

	PCCW F2,E↔NCW F1,E
	CALL(MIDQQ,{QQ(F1)},{QQ(F2)})
	CALL(MIDQQ,1,QQL2)
	DAC 1,QQL2↔DAC 1,QQR2

	TESTZ E,FOLDED↔GO[CW F2,E	;UNDERFACE OF A FOLD.
	LAC QQ(F2)↔DAC QQL1↔DAC QQL2↔GO .+1]
	CALL(WORDO,QQL1)	;LEFT OF V1.
	CALL(WORDO,QQR1)	;RIGHT OF V1.
	CALL(WORDO,QQL2)	;LEFT OF V2.
	CALL(WORDO,QQR2)	;RIGHT OF V2.
	GO L3

;NEITHER NSHARP NOR GOURAUD.
L4:	TESTZ E,FOLDED↔CW F2,E		;UNDERFACE OF A FOLD.
	CALL(WORDO,{QQ(F2)})	;LEFT  OF V1.
	CALL(WORDO,{QQ(F1)})	;RIGHT OF V1.
	CALL(WORDO,{QQ(F2)})	;LEFT  OF V2.
	CALL(WORDO,{QQ(F1)})	;RIGHT OF V2.
	GO L3
DECLARE{QQL1,QQR1,QQL2,QQR2}
ENDR OUTV2D;3/14/74(BGB)---------------------------------------------

SUBN(MIDQQ,Q1,Q2)	;AVERAGE TWO INTENSITY WORDS.
COMMENT .-----------------------------------------------------------.
	ACCUMULATORS{X,P1,P2,A1,A2}
	SAVAC(6)
	LAC A1,Q1↔LAC A2,Q2
	LAC P1,[POINT 9,A1]
	LAC P2,[POINT 9,A2]
	ILDB P1↔ILDB X,P2↔ADD X↔LSH -1↔ROTC -9
	ILDB P1↔ILDB X,P2↔ADD X↔LSH -1↔ROTC -9
	ILDB P1↔ILDB X,P2↔ADD X↔LSH -1↔ROTC -9
	ILDB P1↔ILDB X,P2↔ADD X↔LSH -1↔ROTC -9
	GETAC(6)
	POP2J
ENDR MIDQQ;3/21/74(BGB)----------------------------------------------

END
MEMIO.FAI - EOF.